COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload struct fas dsk (mac lsp)))
C00013 ENDMK
C⊗;
(declare (fasload struct fas dsk (mac lsp)))

(defstruct node-record
 (count 0)
 (class-output nil)
 (superclasses-to-output nil)
 (name nil)
 (in-degree 0)
 (direct-superclasses ())
 (direct-subclasses ())
 (flink nil)
 (blink nil)
 (top nil))

(defmacro block (name . forms)
 `(*catch ',name (progn ,@forms)))

(defmacro return-from (name form)
 `(*throw ',name ,form))

(defmacro unless (x . y) `(cond ((not ,x) ,@y)))

(defmacro when (x . y) `(cond (,x ,@y)))

(defmacro incf (loc) `(setf ,loc (+ ,loc 1)))

(defmacro decf (loc) `(setf ,loc (+ ,loc -1)))

(defmacro node-record (node) `(cadr ,node))

(defmacro loop forms `(do () (()) ,@forms))

(defmacro dolist ((stepper starter) .forms)
 (let ((var (gensym)))
 `(do ((,var ,starter (cdr ,var))
       (,stepper nil))
      ((null ,var))
   (setq ,stepper (car ,var))
   ,@forms)))

(defun union (l1 l2)
 (do ((l1 l1 (cdr l1))
      (l l2))
     ((null l1) l)
     (unless (memq (car l1) l2) (push (car l1) l))))

(declare (special *node-alist*) (special *n*))

(defmacro node-record-exists (node) `(assq ,node *node-alist*))

(defmacro find-node-record (node) `(cadr (assq ,node *node-alist*)))

(defun init () (setq *node-alist* nil) (setq *n* 0))

(defmacro defclass (class superclasses ignore)
 (let ((class-record ()))
  (let ((class-record-entry (node-record-exists class)))
   (cond (class-record-entry
	  (setq class-record (node-record class-record-entry)))
	 (t (incf *n*)
	    (setq class-record (make-node-record name class))
	    (push `(,class ,class-record) *node-alist*))))
  (when superclasses
   (let ((class1-record ())
	 (class2-record ()))
     (let ((class1-record-entry (node-record-exists (car superclasses))))
      (cond (class1-record-entry
	     (setq class1-record (node-record class1-record-entry)))
	    (t (incf *n*)
	       (setq class1-record (make-node-record name (car superclasses)))
	       (push 
	       ` (,(car superclasses) ,class1-record) *node-alist*))))
   (do ((sc superclasses (cdr sc))
        (ds nil))
       ((null sc) (setf (direct-superclasses class-record) (reverse ds)))
    (let ((class2 (cadr sc)))
     (incf (in-degree class1-record))
     (push class1-record ds)
     (when class2
      (let ((class2-record-entry (node-record-exists class2)))
       (cond (class2-record-entry
	      (setq class2-record (node-record class2-record-entry)))
	     (t (incf *n*)
	        (setq class2-record (make-node-record name class2))
	        (push 
		` (,class2 ,class2-record) *node-alist*))))
      (record-relation class1-record class2-record))
     (record-relation class-record class1-record)
     (setq class1-record class2-record))))))
 `(quote ,class))

;;; Records that node1<node2
;;;
(defun record-relation (node1-record node2-record)
  (incf (count node2-record))
  (setf (top node1-record)
	(cons node2-record (top node1-record)))
  (name node1-record))

(defun find-loop (class)
 (let ((ans
	(cond ((< 0 (count class))
	       `(,(name class)))
	      (t ()))))
      (dolist (superclass (direct-superclasses class))
	      (setq ans (union (find-loop superclass) ans)))
      ans))

(defun topologically-sort (class-name)
 (let* ((cpl ())
	(dummy-node (make-node-record name nil flink nil blink nil))
	(none dummy-node)
	(front dummy-node)
	(output-class (find-node-record class-name)))
  ;; Do the sort
  (setf (blink output-class) none)
  (setf (flink output-class) none)
  (setq front output-class)
  (push output-class cpl)
  (setf (class-output output-class) t)
  (setf (superclasses-to-output output-class) (direct-superclasses output-class))
  (decf *n*)
  (loop
   ;; Recalculate the counts and queue of 0-count nodes
   (dolist (p (top output-class)) (decf (count p)))
   (setq output-class ())
   (block search
    (do ((class front (flink class)))
	((eq class none))
      (do ((supers (superclasses-to-output class) (cdr supers)))
	  ((null supers))
       (unless (class-output (car supers))
	       (when (zerop (count (car supers)))
		     (setf (superclasses-to-output class) (cdr supers))
		     (when (null (superclasses-to-output class))
		      (setf (flink (blink class)) (flink class))
		      (setf (blink (flink class)) (blink class))
		      (when (eq class front)
			    (setq front (flink class))))
		     (setq output-class (car supers))
		     (return-from search t))))))
   (when (null output-class)
	 (cond ((zerop *n*) (return cpl))
	       (t 
		(princ `|Loop found: |)
		(princ (find-loop (find-node-record class-name)))
		(terpri)
		(princ '|Current order: |)
		(princ (reverse (mapcar #'(lambda (class) (name class)) cpl)))
		(terpri)
		(error '|Inconsistent Lattice|)
		  (return nil))))
   (setf (class-output output-class) t)
   (setf (superclasses-to-output output-class)
	 (direct-superclasses output-class))
   (setf (blink output-class) none)
   (setf (flink output-class) front)
   (setf (blink (flink front)) output-class)
   (setq front output-class)
   (push output-class cpl)
   (decf *n*))
(let ((ans ()))
     (dolist (class cpl)
	     (push (name class) ans)) 
     ans)))